home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / trigi.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  22.3 KB  |  627 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module trigi)
  13.  
  14. (LOAD-MACSYMA-MACROS MRGMAC)
  15.  
  16. (DECLARE-TOP(GENPREFIX TRI)
  17.      (SPECIAL VARLIST ERRORSW $DEMOIVRE)
  18.      (FLONUM (TAN) (COT) (SEC) (CSC)
  19.          (ATAN2) (ATAN1) (ACOT)
  20.          (SINH) (COSH) (TANH) (COTH) (CSCH) (SECH)
  21.          (ASINH) (ACSCH)
  22.          (T//$ FLONUM FLONUM NOTYPE))
  23.      (*EXPR $BFLOAT TEVAL SIGNUM1 ZEROP1 ISLINEAR EXPAND1
  24.         TIMESK ADDK MAXIMA-INTEGERP EVOD LOGARC
  25.         MEVENP EQTEST HALFANGLE COEFF))
  26.  
  27. (DEFMVAR $%PIARGS T)
  28. (DEFMVAR $%IARGS T)
  29. (DEFMVAR $TRIGINVERSES '$ALL)
  30. (DEFMVAR $TRIGEXPAND NIL)
  31. (DEFMVAR $TRIGEXPANDPLUS T)
  32. (DEFMVAR $TRIGEXPANDTIMES T)
  33. (DEFMVAR $TRIGSIGN T)
  34. (DEFMVAR $EXPONENTIALIZE NIL)
  35. (DEFMVAR $LOGARC NIL)
  36. (DEFMVAR $HALFANGLES NIL)
  37.  
  38. (DEFMVAR 1//2 '((RAT SIMP) 1 2))
  39. (DEFMVAR -1//2 '((RAT SIMP) -1 2))
  40. (DEFMVAR %PI//4 '((MTIMES SIMP) ((RAT SIMP) 1 4.) $%PI))
  41. (DEFMVAR %PI//2 '((MTIMES SIMP) ((RAT SIMP) 1 2) $%PI))
  42. (DEFMVAR SQRT2//2 '((MTIMES SIMP) ((RAT SIMP) 1 2)
  43.                   ((MEXPT SIMP) 2 ((RAT SIMP) 1 2))))
  44. (DEFMVAR -SQRT2//2 '((MTIMES SIMP) ((RAT SIMP) -1 2)
  45.                    ((MEXPT SIMP) 2 ((RAT SIMP) 1 2))))
  46. (DEFMVAR SQRT3//2 '((MTIMES SIMP) ((RAT SIMP) 1 2)
  47.                   ((MEXPT SIMP) 3 ((RAT SIMP) 1 2))))
  48. (DEFMVAR -SQRT3//2 '((MTIMES SIMP) ((RAT SIMP) -1 2)
  49.                    ((MEXPT SIMP) 3 ((RAT SIMP) 1 2))))
  50.  
  51. ;;; Arithmetic utilities.
  52.  
  53. (DEFMFUN SQRT1-X^2 (X) (POWER (SUB 1 (POWER X 2)) 1//2))
  54.  
  55. (DEFMFUN SQRT1+X^2 (X) (POWER (ADD 1 (POWER X 2)) 1//2))
  56.  
  57. (DEFMFUN SQRTX^2-1 (X) (POWER (ADD (POWER X 2) -1) 1//2))
  58.  
  59. (DEFMFUN SQ-SUMSQ (X Y) (POWER (ADD (POWER X 2) (POWER Y 2)) 1//2))
  60.  
  61. (DEFMFUN TRIGP (FUNC) (MEMQ FUNC '(%SIN %COS %TAN %CSC %SEC %COT
  62.                    %SINH %COSH %TANH %CSCH %SECH %COTH)))
  63.  
  64. (DEFMFUN ARCP (FUNC) (MEMQ FUNC '(%ASIN %ACOS %ATAN %ACSC %ASEC %ACOT
  65.                   %ASINH %ACOSH %ATANH %ACSCH %ASECH %ACOTH)))
  66.  
  67. (DEFPROP %SIN SIMP-%SIN OPERATORS)
  68. (DEFPROP %COS SIMP-%COS OPERATORS)
  69. (DEFPROP %TAN SIMP-%TAN OPERATORS)
  70. (DEFPROP %COT SIMP-%COT OPERATORS)
  71. (DEFPROP %CSC SIMP-%CSC OPERATORS)
  72. (DEFPROP %SEC SIMP-%SEC OPERATORS)
  73. (DEFPROP %SINH SIMP-%SINH OPERATORS)
  74. (DEFPROP %COSH SIMP-%COSH OPERATORS)
  75. (DEFPROP %TANH SIMP-%TANH OPERATORS)
  76. (DEFPROP %COTH SIMP-%COTH OPERATORS)
  77. (DEFPROP %CSCH SIMP-%CSCH OPERATORS)
  78. (DEFPROP %SECH SIMP-%SECH OPERATORS)
  79. (DEFPROP %ASIN SIMP-%ASIN OPERATORS)
  80. (DEFPROP %ACOS SIMP-%ACOS OPERATORS)
  81. (DEFPROP %ATAN SIMP-%ATAN OPERATORS)
  82. (DEFPROP %ACOT SIMP-%ACOT OPERATORS)
  83. (DEFPROP %ACSC SIMP-%ACSC OPERATORS)
  84. (DEFPROP %ASEC SIMP-%ASEC OPERATORS)
  85. (DEFPROP %ASINH SIMP-%ASINH OPERATORS)
  86. (DEFPROP %ACOSH SIMP-%ACOSH OPERATORS)
  87. (DEFPROP %ATANH SIMP-%ATANH OPERATORS)
  88. (DEFPROP %ACOTH SIMP-%ACOTH OPERATORS)
  89. (DEFPROP %ACSCH SIMP-%ACSCH OPERATORS)
  90. (DEFPROP %ASECH SIMP-%ASECH OPERATORS)
  91.  
  92. (DEFMFUN SIMP-%SIN (FORM Y Z) 
  93.   (ONEARGCHECK FORM)
  94.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  95.   (COND ((FLOATP Y) (SIN Y))
  96.     ((AND $NUMER (INTEGERP Y))
  97.      (SIN (FLOAT Y 2.0d0 )))
  98.     (($BFLOATP Y) ($BFLOAT FORM))
  99.     ((AND $%PIARGS (COND ((ZEROP1 Y) 0) ((LINEARP Y '$%PI) (%PIARGS-SIN\COS Y)))))
  100.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%SINH (COEFF Y '$%I 1))))
  101.     ((AND $TRIGINVERSES (NOT (ATOM Y))
  102.           (COND ((EQ '%ASIN (SETQ Z (CAAR Y))) (CADR Y))
  103.             ((EQ '%ACOS Z) (SQRT1-X^2 (CADR Y)))
  104.             ((EQ '%ATAN Z) (DIV (CADR Y) (SQRT1+X^2 (CADR Y))))
  105.             ((EQ '%ACOT Z) (DIV 1 (SQRT1+X^2 (CADR Y))))
  106.             ((EQ '%ASEC Z) (DIV (SQRTX^2-1 (CADR Y)) (CADR Y)))
  107.             ((EQ '%ACSC Z) (DIV 1 (CADR Y)))
  108.             ((EQ '$ATAN2 Z) (DIV (CADR Y) (SQ-SUMSQ (CADR Y) (CADDR Y)))))))
  109.     ((AND $TRIGEXPAND (TRIGEXPAND '%SIN Y)))
  110.     ($EXPONENTIALIZE (EXPONENTIALIZE '%SIN Y))
  111.     ((AND $HALFANGLES (HALFANGLE '%SIN Y)))
  112.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%SIN (NEG Y))))
  113.     (T (EQTEST (LIST '(%SIN) Y) FORM))))
  114.  
  115. (DEFMFUN SIMP-%COS (FORM Y Z) 
  116.   (ONEARGCHECK FORM)
  117.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  118.   (COND ((FLOATP Y) (COS Y))
  119.     ((AND $NUMER (INTEGERP Y))
  120.      (COS (FLOAT Y 2.0d0 )))
  121.     (($BFLOATP Y) ($BFLOAT FORM))
  122.     ((AND $%PIARGS (COND ((ZEROP1 Y) 1) ((LINEARP Y '$%PI) (%PIARGS-SIN\COS (ADD %PI//2 Y))))))
  123.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%COSH (COEFF Y '$%I 1)))
  124.     ((AND $TRIGINVERSES (NOT (ATOM Y))
  125.           (COND ((EQ '%ACOS (SETQ Z (CAAR Y))) (CADR Y))
  126.             ((EQ '%ASIN Z) (SQRT1-X^2 (CADR Y)))
  127.             ((EQ '%ATAN Z) (DIV 1 (SQRT1+X^2 (CADR Y))))
  128.             ((EQ '%ACOT Z) (DIV (CADR Y) (SQRT1+X^2 (CADR Y))))
  129.             ((EQ '%ASEC Z) (DIV 1 (CADR Y)))
  130.             ((EQ '%ACSC Z) (DIV (SQRTX^2-1 (CADR Y)) (CADR Y)))
  131.             ((EQ '$ATAN2 Z) (DIV (CADDR Y) (SQ-SUMSQ (CADR Y) (CADDR Y)))))))
  132.     ((AND $TRIGEXPAND (TRIGEXPAND '%COS Y)))
  133.     ($EXPONENTIALIZE (EXPONENTIALIZE '%COS Y))
  134.     ((AND $HALFANGLES (HALFANGLE '%COS Y)))
  135.     ((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%COS (NEG Y)))
  136.     (T (EQTEST (LIST '(%COS) Y) FORM))))
  137.  
  138. (DEFUN %PIARGS-SIN\COS (X)
  139.   (LET ($FLOAT COEFF RATCOEFF zl-REM)
  140.     (SETQ RATCOEFF (COEFFICIENT X '$%PI 1)
  141.       COEFF (LINEARIZE RATCOEFF) zl-REM (COEFFICIENT X '$%PI 0))
  142.     (COND ((ZEROP1 zl-REM) (%PIARGS COEFF RATCOEFF))
  143.       ((NOT (MEVENP (CAR COEFF))) NIL)
  144.       ((EQUAL 0 (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%SIN zl-REM))
  145.       ((EQUAL 1 X) (NEG (CONS-EXP '%SIN zl-REM)))
  146.       ((ALIKE1 1//2 X) (CONS-EXP '%COS zl-REM))
  147.       ((ALIKE1 '((RAT) 3 2) X) (NEG (CONS-EXP '%COS zl-REM))))))
  148.  
  149. (DEFMFUN SIMP-%TAN (FORM Y Z)
  150.   (ONEARGCHECK FORM)
  151.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  152.   (COND ((FLOATP Y) (TAN Y))
  153.     ((AND $NUMER (INTEGERP Y))
  154.      (TAN (FLOAT Y 2.0d0 )))
  155.     (($BFLOATP Y) ($BFLOAT FORM))
  156.     ((AND $%PIARGS (COND ((ZEROP1 Y) 0) ((LINEARP Y '$%PI) (%PIARGS-TAN\COT Y)))))
  157.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%TANH (COEFF Y '$%I 1))))
  158.     ((AND $TRIGINVERSES (NOT (ATOM Y))
  159.           (COND ((EQ '%ATAN (SETQ Z (CAAR Y))) (CADR Y))
  160.             ((EQ '%ASIN Z) (DIV (CADR Y) (SQRT1-X^2 (CADR Y))))
  161.             ((EQ '%ACOS Z) (DIV (SQRT1-X^2 (CADR Y)) (CADR Y)))
  162.             ((EQ '%ACOT Z) (DIV 1 (CADR Y)))
  163.             ((EQ '%ASEC Z) (SQRTX^2-1 (CADR Y)))
  164.             ((EQ '%ACSC Z) (DIV 1 (SQRTX^2-1 (CADR Y))))
  165.             ((EQ '$ATAN2 Z) (DIV (CADR Y) (CADDR Y))))))
  166.     ((AND $TRIGEXPAND (TRIGEXPAND '%TAN Y)))
  167.     ($EXPONENTIALIZE (EXPONENTIALIZE '%TAN Y))
  168.     ((AND $HALFANGLES (HALFANGLE '%TAN Y)))
  169.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%TAN (NEG Y))))
  170.     (T (EQTEST (LIST '(%TAN) Y) FORM))))
  171.  
  172. (DEFMFUN SIMP-%COT (FORM Y Z)
  173.   (ONEARGCHECK FORM)
  174.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  175.   
  176.   (COND ((FLOATP Y) (COT Y))
  177.     ((AND $NUMER (INTEGERP Y))
  178.      (COT (FLOAT Y 2.0d0 )))
  179.     (($BFLOATP Y) ($BFLOAT FORM))
  180.     ((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'COT))
  181.                  ((AND (LINEARP Y '$%PI) (SETQ Z (%PIARGS-TAN\COT (ADD %PI//2 Y)))) (NEG Z)))))
  182.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%COTH (COEFF Y '$%I 1))))
  183.     ((AND $TRIGINVERSES (NOT (ATOM Y))
  184.           (COND ((EQ '%ACOT (SETQ Z (CAAR Y))) (CADR Y))
  185.             ((EQ '%ASIN Z) (DIV (SQRT1-X^2 (CADR Y)) (CADR Y)))
  186.             ((EQ '%ACOS Z) (DIV (CADR Y) (SQRT1-X^2 (CADR Y))))
  187.             ((EQ '%ATAN Z) (DIV 1 (CADR Y)))
  188.             ((EQ '%ASEC Z) (DIV 1 (SQRTX^2-1 (CADR Y))))
  189.             ((EQ '%ACSC Z) (SQRTX^2-1 (CADR Y)))
  190.             ((EQ '$ATAN2 Z) (DIV (CADDR Y) (CADR Y))))))
  191.     ((AND $TRIGEXPAND (TRIGEXPAND '%COT Y)))
  192.     ($EXPONENTIALIZE (EXPONENTIALIZE '%COT Y))
  193.     ((AND $HALFANGLES (HALFANGLE '%COT Y)))
  194.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%COT (NEG Y))))
  195.     (T (EQTEST (LIST '(%COT) Y) FORM))))
  196.  
  197. (DEFUN %PIARGS-TAN\COT (X)
  198.     (PROG ($FLOAT COEFF zl-REM)
  199.     (SETQ COEFF (LINEARIZE (COEFFICIENT X '$%PI 1)) zl-REM (COEFFICIENT X '$%PI 0))
  200.     (RETURN (COND ((AND (ZEROP1 zl-REM)
  201.                 (SETQ zl-REM (%PIARGS COEFF NIL))
  202.                 (SETQ COEFF (%PIARGS (CONS (CAR COEFF) (RPLUS 1//2 (CDR COEFF)))
  203.                          NIL)))
  204.                (DIV zl-REM COEFF))
  205.               ((NOT (MEVENP (CAR COEFF))) NIL)
  206.               ((INTEGERP (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%TAN zl-REM))
  207.               ((OR (ALIKE1 1//2 X) (ALIKE1 '((RAT) 3 2) X)) (NEG (CONS-EXP '%COT zl-REM)))))))
  208.  
  209. (DEFMFUN SIMP-%CSC (FORM Y Z)
  210.   (ONEARGCHECK FORM)
  211.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  212.   (COND ((FLOATP Y) (CSC Y))
  213.     ((AND $NUMER (INTEGERP Y))
  214.      (CSC (FLOAT Y 2.0d0 )))
  215.     (($BFLOATP Y) ($BFLOAT FORM))
  216.     ((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'CSC))
  217.                  ((LINEARP Y '$%PI) (%PIARGS-CSC\SEC Y)))))
  218.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%CSCH (COEFF Y '$%I 1))))
  219.     ((AND $TRIGINVERSES (NOT (ATOM Y))
  220.           (COND ((EQ '%ACSC (SETQ Z (CAAR Y))) (CADR Y))
  221.             ((EQ '%ASIN Z) (DIV 1 (CADR Y)))
  222.             ((EQ '%ACOS Z) (DIV 1 (SQRT1-X^2 (CADR Y))))
  223.             ((EQ '%ATAN Z) (DIV (SQRT1+X^2 (CADR Y)) (CADR Y)))
  224.             ((EQ '%ACOT Z) (SQRT1+X^2 (CADR Y)))
  225.             ((EQ '%ASEC Z) (DIV (CADR Y) (SQRTX^2-1 (CADR Y))))
  226.             ((EQ '$ATAN2 Z) (DIV (SQ-SUMSQ (CADR Y) (CADDR Y)) (CADR Y))))))
  227.     ((AND $TRIGEXPAND (TRIGEXPAND '%CSC Y)))
  228.     ($EXPONENTIALIZE (EXPONENTIALIZE '%CSC Y))
  229.     ((AND $HALFANGLES (HALFANGLE '%CSC Y)))
  230.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%CSC (NEG Y))))
  231.     
  232.     (T (EQTEST (LIST '(%CSC) Y) FORM))))
  233.  
  234. (DEFMFUN SIMP-%SEC (FORM Y Z)
  235.   (ONEARGCHECK FORM)
  236.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  237.   (COND ((FLOATP Y) (SEC Y))
  238.     ((AND $NUMER (INTEGERP Y))
  239.      (SEC (FLOAT Y 2.0d0 )))
  240.     (($BFLOATP Y) ($BFLOAT FORM))
  241.     ((AND $%PIARGS (COND ((ZEROP1 Y) 1) ((LINEARP Y '$%PI) (%PIARGS-CSC\SEC (ADD %PI//2 Y))))))
  242.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%SECH (COEFF Y '$%I 1)))
  243.     ((AND $TRIGINVERSES (NOT (ATOM Y))
  244.           (COND ((EQ '%ASEC (SETQ Z (CAAR Y))) (CADR Y))
  245.             ((EQ '%ASIN Z) (DIV 1 (SQRT1-X^2 (CADR Y))))
  246.             ((EQ '%ACOS Z) (DIV 1 (CADR Y)))
  247.             ((EQ '%ATAN Z) (SQRT1+X^2 (CADR Y)))
  248.             ((EQ '%ACOT Z) (DIV (SQRT1+X^2 (CADR Y)) (CADR Y)))
  249.             ((EQ '%ACSC Z) (DIV (CADR Y) (SQRTX^2-1 (CADR Y))))
  250.             ((EQ '$ATAN2 Z) (DIV (SQ-SUMSQ (CADR Y) (CADDR Y)) (CADDR Y))))))
  251.     ((AND $TRIGEXPAND (TRIGEXPAND '%SEC Y)))
  252.     ($EXPONENTIALIZE (EXPONENTIALIZE '%SEC Y))
  253.     ((AND $HALFANGLES (HALFANGLE '%SEC Y)))
  254.     ((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%SEC (NEG Y)))
  255.     
  256.     (T (EQTEST (LIST '(%SEC) Y) FORM))))
  257.  
  258. (DEFUN %PIARGS-CSC\SEC (X)
  259.   (PROG ($FLOAT COEFF zl-REM)
  260.     (SETQ COEFF (LINEARIZE (COEFFICIENT X '$%PI 1)) zl-REM (COEFFICIENT X '$%PI 0))
  261.     (RETURN (COND ((AND (ZEROP1 zl-REM) (SETQ zl-REM (%PIARGS COEFF NIL))) (DIV 1 zl-REM))
  262.               ((NOT (MEVENP (CAR COEFF))) NIL)
  263.               ((EQUAL 0 (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%CSC zl-REM))
  264.               ((EQUAL 1 X) (NEG (CONS-EXP '%CSC zl-REM)))
  265.               ((ALIKE1 1//2 X) (CONS-EXP '%SEC zl-REM))
  266.               ((ALIKE1 '((RAT) 3 2) X) (NEG (CONS-EXP '%SEC zl-REM)))))))
  267.  
  268. (DEFMFUN SIMP-%ATAN (FORM Y Z)
  269.   (ONEARGCHECK FORM)
  270.   (SETQ Y (SIMPCHECK (CADR FORM) Z))
  271.   (COND ((FLOATP Y) (ATAN1 Y))
  272.     ((AND $NUMER (INTEGERP Y))
  273.      (ATAN1 (FLOAT Y 2.0d0 )))
  274.     (($BFLOATP Y) ($BFLOAT FORM))
  275.     ((AND $%PIARGS
  276.           (COND ((ZEROP1 Y) 0) ((EQUAL 1 Y) %PI//4) ((EQUAL -1 Y) (NEG %PI//4)))))
  277.     ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ATANH (COEFF Y '$%I 1))))
  278.     ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
  279.           (IF (EQ (CAAR Y) '%TAN) (CADR Y))))
  280.     ($LOGARC (LOGARC '%ATAN Y))
  281.     ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ATAN (NEG Y))))
  282.     (T (EQTEST (LIST '(%ATAN) Y) FORM))))
  283.  
  284. (DEFUN %PIARGS (X RATCOEFF)
  285.   (COND ((AND (INTEGERP (CAR X)) (INTEGERP (CDR X))) 0)
  286.     ((NOT (MEVENP (CAR X))) 
  287.      (COND ((NULL RATCOEFF) NIL)
  288.            ((ALIKE1 (CDR X) '((RAT) 1 2))
  289.         (POWER -1 (ADD RATCOEFF -1//2)))))
  290.     ((OR (ALIKE1 '((RAT) 1 6) (SETQ X (MMOD (CDR X) 2))) (ALIKE1 '((RAT) 5 6) X)) 1//2)
  291.     ((OR (ALIKE1 '((RAT) 1 4) X) (ALIKE1 '((RAT) 3 4) X)) (DIV (POWER 2 1//2) 2))
  292.     ((OR (ALIKE1 '((RAT) 1 3) X) (ALIKE1 '((RAT) 2 3) X)) (DIV (POWER 3 1//2) 2))
  293.     ((ALIKE1 1//2 X) 1)
  294.     ((OR (ALIKE1 '((RAT) 7 6) X) (ALIKE1 '((RAT) 11 6) X)) -1//2)
  295.     ((OR (ALIKE1 '((RAT) 4 3) X) (ALIKE1 '((RAT) 5 3) X)) (DIV (POWER 3 1//2) -2))
  296.     ((OR (ALIKE1 '((RAT) 5 4) X) (ALIKE1 '((RAT) 7 4) X)) (MUL -1//2 (POWER 2 1//2)))
  297.     ((ALIKE1 '((RAT) 3 2) X) -1)))
  298.  
  299. (DEFUN LINEARIZE (FORM)
  300.   (COND ((INTEGERP FORM) (CONS 0 FORM))
  301.     ((NUMBERP FORM) NIL)
  302.     ((ATOM FORM)
  303.      (LET (DUM)
  304.        (COND ((SETQ DUM (EVOD FORM))
  305.           (IF (EQ '$EVEN DUM) '(2 . 0) '(2 . 1)))
  306.          ((MAXIMA-INTEGERP FORM) '(1 . 0)))))
  307.     ((EQ 'RAT (CAAR FORM)) (CONS 0 FORM))
  308.     ((EQ 'MPLUS (CAAR FORM)) (LIN-MPLUS FORM))
  309.     ((EQ 'MTIMES (CAAR FORM)) (LIN-MTIMES FORM))
  310.     ((EQ 'MEXPT (CAAR FORM)) (LIN-MEXPT FORM))))
  311.  
  312. (DEFUN LIN-MPLUS (FORM)
  313.   (DO ((TL (CDR FORM) (CDR TL)) (DUMMY) (COEFF 0) (zl-REM 0))
  314.       ((NULL TL) (CONS COEFF (MMOD zl-REM COEFF)))
  315.       (SETQ DUMMY (LINEARIZE (CAR TL)))
  316.       (IF (NULL DUMMY) (RETURN NIL)
  317.       (SETQ COEFF (RGCD (CAR DUMMY) COEFF) zl-REM (RPLUS (CDR DUMMY) zl-REM)))))
  318.  
  319. (DEFUN LIN-MTIMES (FORM)
  320.   (DO ((FL (CDR FORM) (CDR FL)) (DUMMY) (COEFF 0) (zl-REM 1))
  321.       ((NULL FL) (CONS COEFF (MMOD zl-REM COEFF)))
  322.       (SETQ DUMMY (LINEARIZE (CAR FL)))
  323.       (COND ((NULL DUMMY) (RETURN NIL))
  324.         (T (SETQ COEFF (RGCD (RTIMES COEFF (CAR DUMMY))
  325.                 (RGCD (RTIMES COEFF (CDR DUMMY)) (RTIMES zl-REM (CAR DUMMY))))
  326.              zl-REM (RTIMES (CDR DUMMY) zl-REM))))))
  327.  
  328. (DEFUN LIN-MEXPT (FORM)
  329.   (PROG (DUMMY)
  330.     (COND ((AND (INTEGERP (CADDR FORM)) (NOT (MINUSP (CADDR FORM)))
  331.             (NOT (NULL (SETQ DUMMY (LINEARIZE (CADR FORM))))))
  332.            (RETURN (CONS (CAR DUMMY) (MMOD (CDR DUMMY) (CADDR FORM))))))))
  333.  
  334. #-cl
  335. (DEFUN LCM (X Y) (QUOTIENT (TIMES X Y) (GCD X Y)))
  336.  
  337. (DEFUN RGCD (X Y)
  338.   (COND ((INTEGERP X)
  339.      (COND ((INTEGERP Y) (GCD X Y))
  340.            (T (LIST '(RAT) (GCD X (CADR Y)) (CADDR Y)))))
  341.     ((INTEGERP Y) (LIST '(RAT) (GCD (CADR X) Y) (CADDR X)))
  342.     (T (LIST '(RAT) (GCD (CADR X) (CADR Y)) (LCM (CADDR X) (CADDR Y))))))
  343.  
  344. (DEFUN MAXIMA-REDUCE (X Y)
  345.   (PROG (GCD)
  346.     (SETQ GCD (GCD X Y) X (QUOTIENT X GCD) Y (QUOTIENT Y GCD))
  347.     (IF (MINUSP Y) (SETQ X (MINUS X) Y (MINUS Y)))
  348.     (RETURN (IF (EQUAL Y 1) X (LIST '(RAT SIMP) X Y)))))
  349.  
  350. ;; The following four functions are generated in code by TRANSL. - JPG 2/1/81
  351.  
  352. (DEFMFUN RPLUS (X Y) (ADDK X Y))
  353.  
  354. (DEFMFUN RDIFFERENCE (X Y) (ADDK X (TIMESK -1 Y)))
  355.  
  356. (DEFMFUN RTIMES (X Y) (TIMESK X Y))
  357.  
  358. (DEFMFUN RREMAINDER (X Y)
  359.   (COND ((EQUAL 0 Y) (DBZ-ERR))
  360.     ((INTEGERP X)
  361.      (COND ((INTEGERP Y) (MAXIMA-REDUCE X Y))
  362.            (T (MAXIMA-REDUCE (TIMES X (CADDR Y)) (CADR Y)))))
  363.     ((INTEGERP Y) (MAXIMA-REDUCE (CADR X) (TIMES (CADDR X) Y)))
  364.     (T (MAXIMA-REDUCE (TIMES (CADR X) (CADDR Y)) (TIMES (CADDR X) (CADR Y))))))
  365.  
  366. (DEFMFUN $EXPONENTIALIZE (EXP)
  367.  (LET ($DEMOIVRE)
  368.       (COND ((ATOM EXP) EXP)
  369.         ((TRIGP (CAAR EXP))
  370.          (EXPONENTIALIZE (CAAR EXP) ($EXPONENTIALIZE (CADR EXP))))
  371.         (T (RECUR-APPLY #'$EXPONENTIALIZE EXP)))))
  372.  
  373. (DEFMFUN EXPONENTIALIZE (OP ARG)
  374.   (COND ((EQ '%SIN OP)
  375.      (DIV (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))
  376.               (MUL 2 '$%I)))
  377.     ((EQ '%COS OP)
  378.      (DIV (ADD (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG))) 2))
  379.     ((EQ '%TAN OP)
  380.      (DIV (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))
  381.               (MUL '$%I (ADD (POWER '$%E (MUL '$%I ARG))
  382.                           (POWER '$%E (MUL -1 '$%I ARG))))))
  383.     ((EQ '%COT OP)
  384.      (DIV (MUL '$%I (ADD (POWER '$%E (MUL '$%I ARG))
  385.                           (POWER '$%E (MUL -1 '$%I ARG))))
  386.               (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
  387.     ((EQ '%CSC OP)
  388.      (DIV (MUL 2 '$%I)
  389.               (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
  390.     ((EQ '%SEC OP)
  391.      (DIV 2 (ADD (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
  392.     ((EQ '%SINH OP)
  393.      (DIV (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG))) 2))
  394.     ((EQ '%COSH OP)
  395.      (DIV (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG))) 2))
  396.     ((EQ '%TANH OP)
  397.      (DIV (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))
  398.               (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))))
  399.     ((EQ '%COTH OP)
  400.      (DIV (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))
  401.               (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))))
  402.     ((EQ '%CSCH OP)
  403.      (DIV 2 (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))))
  404.     ((EQ '%SECH OP)
  405.      (DIV 2 (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))))))
  406.  
  407. (DEFUN COEFFICIENT (EXP VAR POW) (COEFF (EXPAND1 EXP 1 0) VAR POW))
  408.  
  409. (DEFUN MMOD (X MOD)
  410.   (COND ((and (INTEGERP X) (INTEGERP mod))
  411.         (IF (MINUSP (if (zerop mod) x (SETQ X (f- X (f* MOD (// X MOD))))))
  412.             (f+ X MOD)
  413.             X))
  414.         ((and ($ratnump x) ($ratnump mod))
  415.                (let
  416.                    ((d (lcm ($denom x) ($denom mod))))
  417.                  (setq x (mul* d x))
  418.                  (setq mod (mul* d mod))
  419.                  (div (mod x mod) d)))
  420.     (t nil)))
  421. ;    ((AND (NOT (ATOM X)) (EQ 'RAT (CAAR X)))
  422. ;     (LIST '(RAT) (MMOD (CADR X) (f* MOD (CADDR X))) (CADDR X))
  423.  
  424.  
  425. (DEFUN MULTIPLEP (EXP VAR)
  426.   (AND (NOT (ZEROP1 EXP)) (ZEROP1 (SUB EXP (MUL VAR (COEFF EXP VAR 1))))))
  427.  
  428. (DEFUN LINEARP (EXP VAR)
  429.  (AND (SETQ EXP (ISLINEAR (EXPAND1 EXP 1 0) VAR)) (NOT (EQUAL (CAR EXP) 0))))
  430.  
  431. (DEFMFUN MMINUSP (X) (= -1 (SIGNUM1 X)))
  432.  
  433. (DEFMFUN MMINUSP* (X)
  434.  (LET (SIGN)
  435.       (SETQ SIGN (CSIGN X))
  436.       (OR (MEMQ SIGN '($NEG $NZ))
  437.       (AND (MMINUSP X) (NOT (MEMQ SIGN '($POS $PZ)))))))
  438.  
  439. ;; This should give more information somehow.
  440.  
  441. (DEFUN DBZ-ERR ()
  442.  (COND ((NOT ERRORSW) (MERROR "Division by zero"))
  443.        (T (THROW 'ERRORSW T))))
  444.  
  445. (DEFUN DBZ-ERR1 (FUNC)
  446.  (COND ((NOT ERRORSW) (MERROR "Division by zero in ~A function" FUNC))
  447.        (T (THROW 'ERRORSW T))))
  448.  
  449. ;; Only used by LAP code right now.
  450.  
  451. #+PDP10
  452. (DEFUN NUMERIC-ERR (X MSG) (MERROR "~A in ~A function" MSG X))
  453.  
  454. ;; Trig, hyperbolic functions, and inverses, which take real floating args
  455. ;; and return real args.  Checks made for overflow and out of range args.
  456. ;; The following are read-time constants.
  457. ;; This seems bogus.  Probably want (FSC (LSH 1 26.) 0) for the PDP10. -cwh
  458.  
  459. #.(SETQ EPS #+PDP10 (FSC 1.0 -26.)
  460.         #+cl ;(ASH 1.0 #+3600 -24. #-3600 -31.)
  461.         (scale-float 1.0 -24)
  462.             #-(or PDP10 Cl) 1.4E-8)
  463.  
  464. #-cl ;;it already has a value thank you very much
  465. (SETQ PI #.(ATAN 0.0 -1.0))
  466. (eval-when (load eval compile)
  467.   (defvar piby2 (coerce (/ pi 2.0) 'double-float)))
  468.  
  469. ;; This function is in LAP for PDP10 systems.  On the Lisp Machine and
  470. ;; in NIL, this should CONDITION-BIND the appropriate arithmetic overflow
  471. ;; signals and do whatever NUMERIC-ERR or DBZ-ERR does.  Fix later.
  472.  
  473. #-(OR PDP10 CL) (DEFMACRO T//$ (X Y FUNCTION) FUNCTION ;Ignored
  474.                  `(//$ ,X ,Y))
  475. #+CL
  476. (DEFMACRO T//$ (X Y FUNCTION)
  477.   (IF (EQUAL Y 0.0)
  478.       ;; DEFEAT INCOMPETENTLY DONE COMPILER:OPTIMIZATION.
  479.       `(T//$-FOO ,X ,Y ,FUNCTION)
  480.       `(//$ ,X ,Y)))
  481. #+CL
  482. (DEFUN T//$-FOO (X Y FUNCTION) FUNCTION
  483.        (//$ X Y))
  484.  
  485. #+PDP10 (LAP-A-LIST '(
  486.  
  487. (LAP     T//$ SUBR)
  488. (ARGS     T//$ (NIL . 3))
  489.     (PUSH P (% 0 0 FLOAT1))
  490.     (JRST 2 @ (% 0 0 NEXTA))
  491. NEXTA    (MOVE TT 0 A)
  492.     (FDVR TT 0 B)            ;DIVIDE TT BY SECOND ARG
  493.     (JFCL 10 UFLOW)
  494. ANS    (POPJ P)
  495. UFLOW    (MOVE A C)
  496.     (SKIPN 0 0 B)
  497.      (JCALL 1 'DBZ-ERR1)
  498.     (MOVEI B 'OVERFLOW)
  499.     (JSP T NEXTB)
  500. NEXTB    (TLNN T 64.)
  501.      (JCALL 2 'NUMERIC-ERR)
  502.     (MOVEI B 'UNDERFLOW)
  503.     (SKIPN 0 (SPECIAL ZUNDERFLOW))
  504.      (JCALL 2 'NUMERIC-ERR)
  505.     (MOVEI TT 0)
  506.     (JRST 0 ANS)
  507. NIL ))
  508.  
  509. ;; Numeric functions (SIN, COS, LOG, EXP are built in to Lisp).
  510.  
  511. (DEFMFUN TAN (X) (T//$ (SIN X) (COS X) 'TAN))
  512.  
  513. (DEFMFUN COT (X) (T//$ (COS X) (SIN X) 'COT))
  514.  
  515. (DEFMFUN SEC (X) (T//$ 1.0 (COS X) 'SEC))
  516.  
  517. (DEFMFUN CSC (X) (T//$ 1.0 (SIN X) 'CSC))
  518.  
  519. ;; #.<form> means to evaluate <form> at read-time.
  520.  
  521. (DECLARE-TOP (FLONUM YY YFLO))
  522.  
  523. #-Franz
  524. (DEFMFUN ASIN (NUM)
  525.   (LET ((YFLO (FLOAT NUM)))
  526.     (COND ((> (ABS YFLO) 1.0) (LOGARC '%ASIN YFLO))
  527.       ((< (ABS YFLO) #.(SQRT EPS)) YFLO)
  528.       (T (*$ (ATAN (ABS YFLO) (SQRT (-$ 1.0 (*$ YFLO YFLO))))
  529.          (IF (< YFLO 0.0) -1.0 1.0))))))
  530.  
  531. #-Franz
  532. (DEFMFUN ACOS (NUM) 
  533.   (LET ((YFLO (FLOAT NUM)))
  534.     (COND ((> (ABS YFLO) 1.0) (LOGARC '%ACOS YFLO))
  535.       ((< (ABS YFLO) #.(SQRT EPS)) (-$ #.PIBY2 YFLO))
  536.       (T (ATAN (SQRT (-$ 1.0 (*$ YFLO YFLO))) YFLO)))))
  537.  
  538. #+MACLISP
  539. (DEFUN ATAN2 (Y X)
  540.   (LET ((YFLO (ATAN (ABS Y) X))) (IF (MINUSP Y) (-$ YFLO) YFLO)))
  541.  
  542. (DEFMFUN ATAN1 (NUM)
  543.    (LET ((YFLO (FLOAT NUM)))
  544.     (*$ (ATAN (ABS YFLO) 1.0) (IF (MINUSP YFLO) -1.0 1.0))))
  545.  
  546. (DEFMFUN ACOT (NUM)
  547.    (LET ((YFLO (FLOAT NUM)))
  548.     (*$ (ATAN 1.0 (ABS YFLO)) (IF (MINUSP YFLO) -1.0 1.0))))
  549.  
  550. (DEFMFUN ASEC (NUM)
  551.    (LET ((YFLO (FLOAT NUM)))
  552.     (IF (< (ABS YFLO) 1.0) (LOGARC '%ASEC YFLO)) (ACOS (//$ YFLO))))
  553.  
  554. (DEFMFUN ACSC (NUM)
  555.    (LET ((YFLO (FLOAT NUM)))
  556.     (IF (< (ABS YFLO) 1.0) (LOGARC '%ACSC YFLO)) (ASIN (//$ YFLO))))
  557.  
  558. (DEFMFUN SINH (NUM)
  559.   (LET ((YY (FLOAT NUM)) (YFLO 0.0))
  560.     (COND ((< (ABS YY) #.(SQRT EPS)) YY)
  561.       (T (SETQ YFLO (EXP (ABS YY)) YFLO (//$ (-$ YFLO (//$ YFLO)) 2.0))
  562.          (IF (< YY 0.0) (-$ YFLO) YFLO)))))
  563.  
  564. (DEFMFUN COSH (NUM)
  565.    (LET ((YFLO (FLOAT NUM)))
  566.     (SETQ YFLO (EXP (ABS YFLO))) (//$ (+$ YFLO (//$ YFLO)) 2.0)))
  567.  
  568. (DEFMFUN TANH (NUM)
  569.   (LET ((YY (FLOAT NUM)) (YFLO 0.0))
  570.     (COND ((< (ABS YY) #.(SQRT EPS)) YY)
  571.       (T (SETQ YFLO (EXP (*$ -2.0 (ABS YY))) YFLO (//$ (1-$ YFLO) (1+$ YFLO)))
  572.          (IF (PLUSP YY) (-$ YFLO) YFLO)))))
  573.  
  574. (DEFMFUN COTH (NUM)
  575.   (LET ((YY (FLOAT NUM)) (YFLO 0.0))
  576.     (COND ((< (ABS YY) #.(SQRT EPS)) (//$ YY))
  577.       (T (SETQ YFLO (EXP (*$ -2.0 (ABS YY))) YFLO (T//$ (1+$ YFLO) (1-$ YFLO) 'COTH))
  578.          (IF (PLUSP YY) (-$ YFLO) YFLO)))))
  579.  
  580. (DEFMFUN CSCH (NUM)
  581.   (LET ((YY (FLOAT NUM)) (YFLO 0.0))
  582.     (COND ((< (ABS YY) #.(SQRT EPS)) (//$ YY))
  583.       (T (SETQ YFLO (EXP (-$ (ABS YY)))
  584.            YFLO (T//$ (*$ 2.0 YFLO)
  585.                   (1-$ (IF (< YFLO #.(SQRT EPS)) 0.0 (*$ YFLO YFLO))) 'CSCH))
  586.          (IF (PLUSP YY) (-$ YFLO) YFLO)))))
  587.  
  588. (DEFMFUN SECH (NUM)
  589.   (LET ((YFLO (FLOAT NUM))) (SETQ YFLO (EXP (-$ (ABS YFLO))))
  590.     (//$ YFLO 0.5 (1+$ (IF (< YFLO #.(SQRT EPS)) 0.0 (*$ YFLO YFLO))))))
  591.  
  592. (DEFMFUN ACOSH (NUM)
  593.    (LET ((YFLO (FLOAT NUM)))
  594.      (COND ((< YFLO 1.0) (LOGARC '%ACOSH YFLO))
  595.        ((> YFLO #.(SQRT (//$ EPS))) (LOG (*$ 2.0 YFLO)))
  596.        (T (LOG (+$ (SQRT (1-$ (*$ YFLO YFLO))) YFLO))))))
  597.  
  598. (DEFMFUN ASINH (NUM)
  599.    (LET* ((YY (FLOAT NUM))
  600.       (YFLO (ABS YY)))
  601.      (COND ((< YFLO #.(SQRT EPS)) YFLO)
  602.            (T (SETQ YFLO (LOG (COND ((> YFLO #.(SQRT (//$ EPS))) (*$ 2.0 YFLO))
  603.                      (T (+$ (SQRT (1+$ (*$ YFLO YFLO))) YFLO)))))
  604.           (COND ((MINUSP YY) (-$ YFLO)) (T YFLO))))))
  605.  
  606. (DEFMFUN ATANH (NUM)
  607.    (LET ((YFLO (FLOAT NUM)))
  608.      (COND ((< (ABS YFLO) #.(SQRT EPS)) YFLO)
  609.        ((< (ABS YFLO) 1.0) (//$ (LOG (T//$ (1+$ YFLO) (-$ 1.0 YFLO) 'ATANH)) 2.0))
  610.        ((= 1.0 (ABS YFLO)) (T//$ 1.0 0.0 'ATANH))
  611.        (T (LOGARC '%ATANH YFLO)))))
  612.  
  613. (DEFMFUN ACOTH (NUM)
  614.    (LET ((YFLO (FLOAT NUM)))
  615.      (COND ((> (ABS YFLO) 1.0)
  616.         (//$ (LOG (//$ (+$ 1.0 YFLO) (+$ -1.0 YFLO))) 2.0))
  617.        ((= 1.0 (ABS YFLO)) (T//$ 1.0 0.0 'ACOTH))
  618.        (T (LOGARC '%ACOTH YFLO)))))
  619.  
  620. (DEFMFUN ASECH (NUM)
  621.    (LET ((YFLO (FLOAT NUM)))
  622.     (COND ((OR (MINUSP YFLO) (> YFLO 1.0)) (LOGARC '%ASECH YFLO)))
  623.     (ACOSH (T//$ 1.0 YFLO 'ASECH))))
  624.  
  625. (DEFMFUN ACSCH (NUM) (ASINH (T//$ 1.0 (FLOAT NUM) 'ACSCH)))
  626.  
  627.